home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE07 / INTERNAL / DOSINFO.PAS next >
Encoding:
Pascal/Delphi Source File  |  1996-01-28  |  12.5 KB  |  370 lines
  1. unit DOSInfo;
  2.  
  3. interface
  4.  
  5. uses WinTypes, WinProcs, WinDOS, Strings;
  6.  
  7. function GetFloppyDriveCount: Integer;
  8. function GetFloppyDriveType (index: Integer): Integer;
  9. function GetDriveLabel (drive: Integer): String;
  10. function SetDriveLabel (drive: Integer; VolLabel: String): Integer;
  11. function GetSerialNumber (drive: Byte): LongInt;
  12. function SetSerialNumber (drive: Byte; serNum: LongInt): Bool;
  13. function GetCDDriveLetter: Char; 
  14. function RunningFromCD: Bool;
  15.  
  16. implementation
  17.  
  18. type XFCB = record              { prehistoric extended FCB - yuck }
  19.     extSig: Byte;              { must be $FF for extended flag }
  20.     extRes: array [0..4] of Byte;     { reserved stuff }
  21.     extAttr: Byte;              { file attribute }
  22.     extDrive: Byte;              { drive number }
  23.     extFName: array [0..10] of Char;  { filename }
  24.     extJunk: array [0..24] of Byte;   { rest of the junk is irrelevant }
  25. end;
  26.  
  27. type
  28.     PMIDINFO = ^MIDINFO;
  29.     MIDINFO = record
  30.                   InfoLevel:  Word;
  31.                   SerialNum:  Longint;
  32.                   VolLabel:   array[0..10] of Char;
  33.                   FileSystem: array [0..7] of Char;
  34.               end;
  35.  
  36. var
  37.     R: record     { Real mode call structure }
  38.            di, si, bp, Reserved, bx, dx, cx, ax : Longint;
  39.            Flags, es, ds, fs, gs, ip, sp, ss: Word;
  40.        end;
  41.  
  42. { Read a single byte from CMOS memory }
  43.  
  44. function ReadCMOSByte (idx: Byte): Word; assembler;
  45. asm
  46.     mov al,idx                  { get the wanted index           }
  47.     out 70h,al                  { write address into address reg }
  48.     in  al,71h                  { read the drive type into AL    }
  49.     mov ah,0                    { clear the high byte            }
  50. end;
  51.  
  52. { Count the number of physical (not logical) floppy drives) }
  53.  
  54. function GetFloppyDriveCount: Integer;
  55. var
  56.     regs: TRegisters;
  57. begin
  58.     { Get equipment bits }
  59.     FillChar (regs, sizeof (regs), 0);
  60.     Intr ($11, regs);
  61.     if (regs.AX and 1) = 0 then GetFloppyDriveCount := 0 else
  62.     GetFloppyDriveCount := ((regs.AX and $C0) shr 6) + 1;
  63. end;
  64.  
  65. { Return the type (max KB capacity) of a given floppy drive }
  66.  
  67. function GetFloppyDriveType (index: Integer): Integer;
  68. var
  69.     flopFlags: Word;
  70.  
  71.     function FlagsToKBytes (flags: Word): Integer;
  72.     begin
  73.         case flags of
  74.             0:     FlagsToKBytes := 0;
  75.             1:     FlagsToKBytes := 360;
  76.             2:     FlagsToKBytes := 1200;
  77.             3:     FlagsToKBytes := 720;
  78.             4:     FlagsToKBytes := 1440;
  79.         5:       FlagsToKBytes := 2880;
  80.             else   FlagsToKBytes := -1;
  81.         end
  82.     end;
  83.  
  84. begin
  85.     flopFlags := ReadCMOSByte ($10);
  86.     case index of
  87.         0: GetFloppyDriveType := FlagsToKBytes (flopFlags shr 4);
  88.         1: GetFloppyDriveType := FlagsToKBytes (flopFlags and 15);
  89.         else GetFloppyDriveType := 0;
  90.     end;
  91. end;
  92.  
  93. { Return the drive label of a specified drive }
  94.  
  95. function GetDriveLabel (drive: Integer): String;
  96. var
  97.     i: Integer;
  98.     s: String;
  99.     rec: WinDOS.TSearchRec;
  100.     path: array [0..10] of Char;
  101. begin
  102.     s := '';
  103.     lstrcpy (path, 'X:\*.*');
  104.     path [0] := Chr (drive + $40);               { 1=A, 2=B, etc... }
  105.     WinDOS.FindFirst (path, 8, rec);
  106.     if WinDOS.DOSError = 0 then
  107.     begin
  108.         for i := 0 to 12 do
  109.             if rec.Name [i] = #0 then break
  110.             else if rec.Name [i] <> '.' then s := s + rec.Name [i];
  111.     end;
  112.  
  113.     GetDriveLabel := s;
  114. end;
  115.  
  116. { Initialise 'fcb' for volume label twiddling - bleurgh ! }
  117.  
  118. procedure InitLabelFCB (drive: Byte; var fcb: XFCB);
  119. begin
  120.     FillChar (fcb, sizeof (fcb), 0);
  121.     with fcb do
  122.     begin
  123.         extSig := $ff;        { mark FCB as extended }
  124.      extAttr := 8;        { specify VOLUME attribute }
  125.     extDrive := drive;    { set up drive number (1=A, 2=B..) }
  126.     FillChar (extFName, sizeof (extFName), '?');
  127.     end;
  128. end;
  129.  
  130. { Trash any existing volume label }
  131.  
  132. function NukeVolumeLabel (drive: Byte): Integer;
  133. var
  134.     fcb: XFCB;
  135.     regs: TRegisters;
  136. begin
  137.     FillChar (regs, sizeof (regs), 0);
  138.     InitLabelFCB (drive, fcb);
  139.     regs.ah := $13;
  140.     regs.dx := Ofs (fcb);
  141.     regs.ds := Seg (fcb);
  142.     MSDos (regs);
  143.     NukeVolumeLabel := regs.al;
  144. end;
  145.  
  146. { This routine massages a user-supplied volume label.  It is rejected if
  147.   any invalid characters are supplied, alpha's are uppercased, and it's
  148.   converted into 8.3 format preceeded by 'X:\'. }
  149.  
  150. function MassageVolumeLabel (VolLabel: String): String;
  151. var
  152.    i: Integer;
  153.    str: String;
  154. begin
  155.    str := '';
  156.    MassageVolumeLabel := '';
  157.    { Validate the user input }
  158.    if Length (VolLabel) > 11 then VolLabel [0] := Chr (11);
  159.    for i := 1 to Length (VolLabel) do
  160.    begin
  161.        if StrScan ('*?/\|.,;:+=[]()&^<>"', VolLabel [i]) <> Nil then Exit;
  162.        if Length (str) = 8 then str := str + '.';
  163.        str := str + UpCase (VolLabel [i]);
  164.    end;
  165.  
  166.    MassageVolumeLabel := 'X:\' + str;
  167. end;
  168.  
  169. { create a volume label - assumes there's not one already there }
  170.  
  171. function CreateVolLabel (drive: Byte; volName: String): Integer;
  172. var
  173.     i: Integer;
  174.     regs: TRegisters;
  175.     path: array [0..20] of Char;
  176.  
  177. begin
  178.     CreateVolLabel := -1;
  179.     StrPCopy (path, MassageVolumeLabel (volName));
  180.     if path [0] = #0 then Exit;         { label was invalid }
  181.     path [0] := Chr (drive + $40);      { 1=A, 2=B, etc... }
  182.  
  183.     FillChar (regs, sizeof (regs), 0);  { safe p-mode programming... }
  184.     regs.ah := $3C;                     { specify create file        }
  185.     regs.cx := 8;                       { set volume label attribute }
  186.     regs.dx := Ofs (path);              { set up pointer to name     }
  187.     regs.ds := Seg (path);              { DS:DS is the pointer pair  }
  188.     MSDos (regs);                       { do the business...         }
  189.  
  190.     if not (Odd (regs.Flags)) then      { if no carry, then ok }
  191.     begin
  192.         _lclose (regs.ax);
  193.         CreateVolLabel := 0;
  194.     end;
  195. end;
  196.  
  197. { Higher-level volume settings code.  Takes care of replacing,
  198.   nuking, etc. }
  199.  
  200. function SetDriveLabel (drive: Integer; VolLabel: String): Integer;
  201. var
  202.     err: Integer;
  203.     OldLabel: String;
  204. begin
  205.     err := 0;
  206.     OldLabel := GetDriveLabel (drive);
  207.  
  208.     { If old and new labels are the same, nothing to do }
  209.     if OldLabel <> VolLabel then
  210.     begin
  211.         { If got an old label, then delete it }
  212.         if OldLabel <> '' then err := NukeVolumeLabel (drive);
  213.         { If we've got a new label, then set it up }
  214.         if (err = 0) and (VolLabel <> '') then err := CreateVolLabel (drive, volLabel);
  215.     end;
  216.  
  217.     SetDriveLabel := err;
  218. end;
  219.  
  220. {----------------------------------------------------------------------------}
  221. {    Name:    GetSetMid                                                      }
  222. {    Purpose: Low level code to get or set a MIDINFO data structure for the  }
  223. {             specified drive.  RealModeAX = $6900 for a get and $6901 for a }
  224. {             set operation.                                                 }
  225. {----------------------------------------------------------------------------}
  226.  
  227. function GetSetMid (Drive: Byte; MID: PMIDINFO; RealModeAX: Word): Bool;
  228. var
  229.     Error: Byte;
  230. begin
  231.     { Assume everything ok }
  232.  
  233.     Error := 0;
  234.     GetSetMid := True;
  235.  
  236.     R.ax := RealModeAX;
  237.     R.bx := Drive;
  238.     R.ds := HiWord (Longint (MID));              { Subtle !!! }
  239.     R.dx := LoWord (Longint (MID));
  240.  
  241.     asm
  242.         mov bx, 0021h     { set flags to $00, Real mode interrupt $21 }
  243.         xor cx, cx        { copy 0 words from protected mode stack }
  244.         mov ax, seg R
  245.         mov es, ax        { selector of real mode call structure }
  246.         mov di, offset R  { offset of real mode call structure }
  247.         mov ax, 0300h     { DPMI simulate real mode interrupt }
  248.         int 31h           { do the business }
  249.         jnc @@1           { branch if no error }
  250.         inc Error
  251.     @@1:
  252.     end;
  253.  
  254.     if Error = 1 then GetSetMid := False;
  255. end;
  256.  
  257. {----------------------------------------------------------------------------}
  258. {    Name:    GetMid                                                         }
  259. {    Purpose: Get the MIDINFO record for a specified drive.                  }
  260. {             Uses GetSetMid.  Returns TRUE if successful.                   }
  261. {----------------------------------------------------------------------------}
  262.  
  263. function GetMid (drive: Byte; var mid: MIDINFO): Bool;
  264. var
  265.     p: LongInt;
  266. begin
  267.     { Assume failure }
  268.     GetMid := False;
  269.  
  270.     { Allocate a MIDINFO data structure in DOS address-space }
  271.     p := GlobalDOSAlloc (sizeof (MIDINFO));
  272.  
  273.     if GetSetMid (drive, Ptr (HiWord (p), 0), $6900) then
  274.     begin
  275.         mid := PMIDINFO (Ptr (LoWord (p), 0))^;
  276.         GetMid := True;
  277.     end;
  278.  
  279.     GlobalDOSFree (LoWord (p));
  280. end;
  281.  
  282. {----------------------------------------------------------------------------}
  283. {    Name:    SetMid                                                         }
  284. {    Purpose: Set the MIDINFO record for a specified drive.                  }
  285. {             Uses GetSetMid.  Returns TRUE if successful.                   }
  286. {----------------------------------------------------------------------------}
  287.  
  288. function SetMid (drive: Byte; var mid: MIDINFO): Bool;
  289. var
  290.     p: LongInt;
  291. begin
  292.     { Assume failure }
  293.     SetMid := False;
  294.  
  295.     { Allocate a MIDINFO data structure in DOS address-space }
  296.     p := GlobalDOSAlloc (sizeof (MIDINFO));
  297.     PMIDINFO (Ptr (LoWord (p), 0))^ := mid;
  298.     if GetSetMid (drive, Ptr (HiWord (p), 0), $6901) then SetMid := True;
  299.     GlobalDOSFree (LoWord (p));
  300. end;
  301.  
  302. {----------------------------------------------------------------------------}
  303. {    Name:    GetSerialNumber                                                }
  304. {    Purpose: Get the serial number for a specified drive.                   }
  305. {             If an error occurs, then 0 is returned as the serial number.   }
  306. {----------------------------------------------------------------------------}
  307.  
  308. function GetSerialNumber (drive: Byte): LongInt;
  309. var
  310.     mid: MIDINFO;
  311. begin
  312.     if GetMid (drive, mid) then GetSerialNumber := mid.SerialNum
  313.     else GetSerialNumber := 0;
  314. end;
  315.  
  316. {----------------------------------------------------------------------------}
  317. {    Name:    SetSerialNumber                                                }
  318. {    Purpose: Set the serial number for a specified drive.                   }
  319. {             If no error, TRUE is returned as the function result.          }
  320. {----------------------------------------------------------------------------}
  321.  
  322. function SetSerialNumber (drive: Byte; serNum: LongInt): Bool;
  323. var
  324.     mid: MIDINFO;
  325. begin
  326.     SetSerialNumber := False;
  327.     if GetMid (drive, mid) then
  328.     begin
  329.         mid.SerialNum := serNum;
  330.         SetSerialNumber := SetMid (drive, mid);
  331.     end;
  332. end;
  333.  
  334. {----------------------------------------------------------------------------}
  335. {    Name:    GetCDDriveLetter                                               }
  336. {    Purpose: Return the drive letter of the CD-ROM drive (if any)         }
  337. {             If no CD is present, #0 is returned.                 }
  338. {----------------------------------------------------------------------------}
  339.  
  340. function GetCDDriveLetter: Char; assembler;
  341. asm
  342.         mov  ax,$150B                   { do installation check for MSCDEX }
  343.         mov  bx,$ffff                   { preset the BX register           }
  344.         int  $2F                        { see if MSCDEX is installed       }
  345.         inc  bx                         { was BX register still -1 ?       }
  346.         jz   @@1                        { if so, there ain't no CD-ROM !   }
  347.         xor  bx,bx                      { clear BX register                }
  348.         mov  ax,$1500                   { request starting drive letter    }
  349.         int  $2F                        { result in CX register            }
  350.         add  cl,$41                     { normalise into character 0->$41  }
  351.         mov  bx,cx                      { result in BX register            }
  352. @@1:    mov  ax,bx                      { result in AX                     }
  353.         mov  ah,0                       { clear the high byte              }
  354. end;
  355.  
  356. {----------------------------------------------------------------------------}
  357. {    Name:    RunningFromCD                                                  }
  358. {    Purpose: True if this application is running from CD             }
  359. {----------------------------------------------------------------------------}
  360.  
  361. function RunningFromCD: Bool;
  362. var
  363.     fName: array [0..255] of Char;
  364. begin
  365.     GetModuleFileName (hInstance, fName, sizeof (fName));
  366.     RunningFromCD := (fName [0] = GetCDDriveLetter);
  367. end;
  368.  
  369. end.
  370.